home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / rectangle.em < prev    next >
Encoding:
Text File  |  1992-07-02  |  8.9 KB  |  321 lines
  1.  
  2. ;
  3. ;    Rectangular Paralations
  4. ;    
  5. ;    File        : rectangle
  6. ;
  7. ;    Contents    : make-rectangle, N, S, E and W
  8. ;
  9. ;    Description    : Indeed most unprecedented hackery to create tiled
  10. ;              virtual paralations which can makle use of the
  11. ;              xnet of the MasPar for nearest neighbour
  12. ;              Communication
  13. ;
  14. ;    Author        : SCM
  15. ;    
  16. ;    Change History
  17. ;    
  18. ;    Date    Name    Comment
  19. ;     17:06:92  SCM    Created
  20. ;
  21.  
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81. (defmodule rectangle (standard0 ppl plural) ()
  82.  
  83. ; SOme constant thingies 
  84.  
  85.  
  86. (setq global-field (make-paralation 512))
  87.  
  88. (defun list-tail (list n)
  89.   ;; returns the rest of the list from element n onwards
  90.   (cond 
  91.    ((null list) ())
  92.    ((= n 0) list)
  93.    (t (list-tail (cdr list) (- n 1)))))
  94.  
  95.  
  96. (defun get-context (width height)
  97.   ;; If the requested context is the global context, it uses
  98.   ;; MP-Context as defined in ppl
  99.   (if (and (= width MP-X-Config) (= height MP-Y-Config)) MP-Context
  100.     (mp-make-context width height)))
  101.  
  102. (defun tile-x (w h last-ctxt)
  103.   ;; Generates a list of contexts for one strip of a tiled  virtual
  104.   ;; processor set, if possible it reuses the previous context.
  105.   (cond
  106.    ((<= w 0) ())
  107.    ((< w MP-X-Config) (cons (get-context w h) ()))
  108.    (t (let ((new (if last-ctxt last-ctxt
  109.            (mp-make-context MP-X-Config h))))
  110.     (cons new (tile-x (- w MP-X-Config) h new))))))
  111.  
  112. (defun number-one (ctxt l-w g-w start)
  113.   ;; Numbers one context of a tiled virtual processor set, start is
  114.   ;; the value in the top-left pe, l-w is the width of the tile and
  115.   ;; g-w is the width of the virtual rectangle of pes
  116.   (format t "(number-one ~a ~a ~a ~a)\n" ctxt l-w g-w start)
  117.   (let ((ofst (mp-bang ctxt 1)))
  118.     (mp-edge ctxt  2)
  119.     (mp-assign ctxt ofst (mp-bang ctxt (+ (- g-w l-w) 1)))
  120.     (mp-fi ctxt)
  121.     (mp-set ctxt ofst 0 start)
  122.     (mp-assign ctxt ofst (mp-scan-op ctxt ofst     610))))
  123.  
  124. (defun shared-ctxt-p (ctxt-list)
  125.   ;; Used to see if the next context is the same as the current one,
  126.   ;; if it is we can use the current enumeration to calculate the next
  127.   ;; one so it is passed to the next call of number-x
  128.   (if (null (cdr ctxt-list)) ()
  129.     (= (car ctxt-list) (cadr ctxt-list))))
  130.  
  131. (defun number-x (ctxt-list last start width left)
  132.   ;; Generates enumeration plurals for one row of contexts of a tiled
  133.   ;; virtual processor set. start is the value of the top left virtual
  134.   ;; pe. Where the context is shared the values can be derrived from
  135.   ;; the previous one.
  136.   (let ((ofst (cond
  137.            ((null ctxt-list) ())
  138.            ((null last) 
  139.         (number-one (car ctxt-list)
  140.                   (if (> left MP-X-Config) MP-X-Config left)
  141.                 width start))
  142.            (t (mp-bin-op (car ctxt-list) last
  143.                  (mp-bang (car ctxt-list) MP-X-Config)     610)))))
  144.     (if (null ofst) ()
  145.       (cons ofst (number-x (cdr ctxt-list) 
  146.                (if (shared-ctxt-p ctxt-list) ofst ()) 
  147.                (+ start MP-X-Config) width (- left MP-X-Config))))))
  148.  
  149.   
  150. (defun l-tile (width height last-ctxt-list start)
  151.   ;; creates a list of pairs of lists of contexts and offsets. Each of
  152.   ;; the pairs represents one horizontal strip of a tiled virtual
  153.   ;; processor set. These can then be turned into a list of contexts
  154.   ;; and a list of offsets as used in the field/paralation format
  155.   (let ((new-ctxt-list (cond 
  156.             ((<= height 0) ())
  157.             ((< height MP-Y-Config) (tile-x width height ()))
  158.             (t (if last-ctxt-list last-ctxt-list
  159.                  (tile-x width MP-Y-Config ()))))))
  160.     (if (null new-ctxt-list) ()
  161.       (cons
  162.        (cons new-ctxt-list (number-x new-ctxt-list () start width width))
  163.        (l-tile width (- height MP-Y-Config) new-ctxt-list 
  164.            (+ start (* width MP-Y-Config)))))))
  165.  
  166. (defun dispair (l)
  167.   ;; Takes a list of pairs of lists and appends them all into a pair
  168.   ;; of lists (which is much more useful!)
  169.   (if (null l) '(())
  170.     (let ((tmp (dispair (cdr l))))
  171.       (if (null tmp) '(())
  172.     (cons (append (caar l) (car tmp))
  173.           (append (cdar l) (cdr tmp)))))))
  174.  
  175. (defun tile (width height)
  176.   ;; Produces a list of contexts and a list of offsets, which define
  177.   ;; and enumerate a tiled virtual processor set.
  178.   (dispair (l-tile width height () 0)))
  179.  
  180. (defun make-rectangle (w h)
  181.   (let* ((ctxt-ofst-l-pair (tile w h))
  182.      (new-field (make-field (allocate-paralation 
  183.                  (car ctxt-ofst-l-pair) (* w h))
  184.                 (cdr ctxt-ofst-l-pair))))
  185.     ((setter index-internal) (paralation new-field) new-field)
  186.     new-field))
  187.  
  188. ; Communication 
  189. ; =============
  190.  
  191. ; The key of our rectangular communication is a primitive function
  192. ; which performs a shift in a given direction for a row or column of a
  193. ; tiled virtual processor set. The lists of contexts and offsets
  194. ; specify a row or column in the correct order, the function does the
  195. ; shifts and handles all the edges of the tiles and wrap around. Thus
  196. ; the difficult part as far as the lisp is concerned is creating the
  197. ; right lists of contexts and offsets.
  198.  
  199. (defun partial-sub-list (l s n)
  200.   ;; generates a list from l of n elements taking every s'th element
  201.   ;; out of l.
  202.   (if (= n 0) ()
  203.     (cons (car l) (partial-sub-list (list-tail l s) s (- n 1)))))
  204.  
  205. (defun MP-XNET (ctxts ofsts d)
  206.   (format t "(mp-xnet ~a ~a ~a)\n" ctxts ofsts d)
  207.   (mp-xnet ctxts ofsts d))
  208.  
  209. (defun horizontal-lists (ctxts ofsts w d)
  210.   ;; generates lists of contexts and offsets which reperesent
  211.   ;; horizontal strips of the tiled virtual processor set. and then makes
  212.   ;; the appropriate mp-xnet call
  213.   (if (null ctxts) ()
  214.     (progn
  215.       (MP-XNET (partial-sub-list ctxts 1 w) (partial-sub-list ofsts 1 w) d)
  216.       (horizontal-lists (list-tail ctxts w) (list-tail ofsts w) w d))))
  217.  
  218. (defun vertical-lists (ctxts ofsts h w c d)
  219.   ;; generates lists of contexts and offsets which represent vertical
  220.   ;; strips of teh tiled virtual processor set. This is a little
  221.   ;; harder than the horizontal case. We stop when we have made width
  222.   ;; strips, thus c(ount) starts as w(idth). The tops of the columns
  223.   ;; are the first w elements of teh lists so we descend by one
  224.   ;; element each time. The partial lists are made up of elements
  225.   ;; w(idth) elements apart and they have h(eight) elements
  226.   (if (= c 0) ()
  227.     (progn
  228.       (MP-XNET (partial-sub-list ctxts w h) (partial-sub-list ofsts w h) d)
  229.       (vertical-lists (cdr ctxts) (cdr ofsts) h w (- c 1) d))))
  230.  
  231. ; Interfacing to get
  232. ; =========== == ===
  233.  
  234. ; a paralation has associated with it a vector of mappings, one for
  235. ; each direction. We place functions in these slots and put a test in
  236. ; get, if there is a function in a slot then it is applied to the
  237. ; field. We also need to know teh dimensions of the rectangle we can
  238. ; read this info from the attributes slot in the paralation structure.
  239.  
  240. (defclass rectangle-internal (paralation-internal)
  241.   ()
  242.   predicate rectangle-internal-p
  243.   constructor (allocate-rectangle contexts length attributes shape))
  244.  
  245. (defun rectanglep (f) (rectangle-internal-p (paralation f)))
  246.   
  247. (defconstant Width 0)
  248. (defconstant Height 1)
  249.  
  250. (defun make-rectangle-internal (w h)
  251.   ;; at this stage all we really need to know is its width and height
  252.   ;; in context tiles  
  253.   (let ((dimensions (make-vector 2)))
  254.     ((setter vector-ref) dimensions Width w)
  255.     ((setter vector-ref) dimensions Height h)
  256.     dimensions))
  257.  
  258. (defcondition bad-paralation-class ())
  259.  
  260. (defun rectangle-width (f)
  261.   (if (rectanglep f) (vector-ref (attributes (paralation f)) Width)
  262.     (error "Not a rectangle" bad-paralation-class)))
  263.  
  264. (defun rectangle-height (f)
  265.   (if (rectanglep f) (vector-ref (attributes (paralation f)) Height)
  266.     (error "Not a rectangle" bad-paralation-class)))
  267.  
  268. (defun width (f) (/ (+ (rectangle-width f) MP-X-Config (- 1)) MP-X-Config))
  269.  
  270. (defun height (f) (/ (+ (rectangle-height f) MP-Y-Config (- 1)) MP-Y-Config))
  271.  
  272. (defun get-north (f)
  273.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  274.   (vertical-lists (contexts f) (offsets f) (height f) (width f)
  275.           (width f) 0)
  276.   f)
  277.  
  278. (defun get-south (f)
  279.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  280.   (vertical-lists (contexts f) (offsets f) (height f) (width f) 
  281.               (width f) 1)
  282.   f)
  283.  
  284. (defun get-east (f)
  285.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  286.   (horizontal-lists (contexts f) (offsets f) (width f)  3)
  287.   f)
  288.  
  289. (defun get-west (f)
  290.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  291.   (horizontal-lists (contexts f) (offsets f) (width f)  2)
  292.   f)
  293.  
  294. (setq rectangle-getters (make-vector 4))
  295.  
  296. (defconstant N 0)
  297. (defconstant S 1)
  298. (defconstant E  3)
  299. (defconstant W  2)
  300.  
  301. ((setter vector-ref) rectangle-getters N get-north)
  302. ((setter vector-ref) rectangle-getters S get-south)
  303. ((setter vector-ref) rectangle-getters E get-east)
  304. ((setter vector-ref) rectangle-getters W get-west)
  305.  
  306. (defun make-rectangle (w h)
  307.   (let* ((ctxt-ofst-l-pair (tile w h))
  308.      (new-field (make-field (allocate-rectangle
  309.                  (car ctxt-ofst-l-pair) (* w h)
  310.                  (make-rectangle-internal w h)
  311.                  rectangle-getters)
  312.                 (cdr ctxt-ofst-l-pair))))
  313.     ((setter index-internal) (paralation new-field) new-field)
  314.     new-field))
  315.  
  316. (export make-rectangle rectanglep rectangle-width rectangle-height N S E W)
  317.      
  318.                  
  319. )
  320.  
  321.